{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.JavaScript
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- JavaScript syntax - one of the back ends.
--
--------------------------------------------------------------------------------

module WumpusExpr.JavaScript
  (
    
    Program    
  , ppProgram
  
  , program
  ) where

import WumpusExpr.FreshMon
import qualified WumpusExpr.KNormal as K
import WumpusExpr.Operators
import WumpusExpr.Types
import WumpusExpr.Utils hiding ( bitwiseNotU )
import WumpusExpr.VarId

import Text.PrettyExprHPJ                       -- package: pretty-expr-hpj
import Text.PrettyExprHPJ.JavaScript

import Text.PrettyPrint.HughesPJ                -- package: pretty

import Control.Applicative




data Program = Program 
      { proc_main :: Fundef 
      , proc_defs :: [Fundef]
      }
  deriving (Eq,Show)


type VarName = String

data Fundef = Fundef 
    { fun_name       :: VarId
    , fun_args       :: [VarId]
    , fun_body       :: [Stmt]
    } 
  deriving (Eq, Show)


data Stmt = CtxCommand Command
          | IfElse Expr [Stmt] [Stmt]
          | VarDef VarName Expr
          | Return Expr
          | ExprStmt Expr
  deriving (Eq,Show)



data Command = NewPath
             | ClosePath
             | Fill
             | Stroke
             | MoveTo Expr Expr
             | LineTo Expr Expr
             | CurveTo Expr Expr Expr Expr Expr Expr
             | GSave
             | GRestore
             | Scale Expr Expr
             | Rotate Expr
             | Translate Expr Expr
             | Transform Expr Expr Expr Expr Expr Expr
             | ShowText Expr
  deriving (Eq,Show)

-- Is FunCall an expression?
--
data Expr = Val Value
          | UnaryE UnaryOp Expr
          | BinE BinOp Expr Expr
          | RelE RelOp Expr Expr
          | CondE Expr Expr Expr
          | FunCall VarId [Expr]
  deriving (Eq,Show)


data Value = Int Int
           | Float Decimal
           | String String
           | Var VarName
  deriving (Eq,Show)

--------------------------------------------------------------------------------
-- Pretty print

ppProgram :: Program -> Doc
ppProgram (Program main_proc defs) = 
    vcatBlank $ map ppFundef (defs ++ [main_proc])


ppFundef :: Fundef -> Doc
ppFundef (Fundef name args stmts) = 
    text "function" <+> ppVarId name 
         <+> tupled (map ppVarId args) <+> lbrace
         $+$ nest 2 (ppStmts stmts)
         $+$ rbrace


ppStmts :: [Stmt] -> Doc
ppStmts = vcat . map ppStmt

ppStmt :: Stmt -> Doc
ppStmt (CtxCommand cmd)         = semiclose $ text "ctx." <> ppCommand cmd
ppStmt (IfElse e1 s1 s2)        = ppIfElse e1 s1 s2
ppStmt (VarDef name e)          = 
    semiclose $ text name <+> char '=' <+> ppExpr e

ppStmt (Return e)               = semiclose $ text "return" <+> ppExpr e
ppStmt (ExprStmt e)             = semiclose $ ppExpr e

semiclose :: Doc -> Doc
semiclose = (<> char ';')

ppIfElse :: Expr -> [Stmt] -> [Stmt] -> Doc
ppIfElse e1 s1 s2 = 
   text "if" <+> unparse (exprDoc e1) <+> lbrace 
             $+$ nest 2 (ppStmts s1)
             $+$ rbrace <+> text "else" <+> lbrace
             $+$ nest 2 (ppStmts s2)
             $+$ rbrace


ppRel :: RelOp -> DocE -> DocE -> DocE
ppRel EQU       = equalB
ppRel NOT_EQU   = notEqualB 
ppRel LTHAN     = lessThanB
ppRel GTHAN     = greaterThanB
ppRel LT_EQU    = lessThanEqB
ppRel GT_EQU    = greaterThanEqB


ppExpr :: Expr -> Doc
ppExpr = unparse . exprDoc

exprDoc :: Expr -> DocE
exprDoc (Val v)                         = Atom $ ppValue v
exprDoc (UnaryE op e)                   = ppUnary op (exprDoc e)
exprDoc (BinE op e1 e2)                 = ppBinary op (exprDoc e1) (exprDoc e2)
exprDoc (RelE op e1 e2)                 = ppRel op (exprDoc e1) (exprDoc e2)
exprDoc (CondE e1 tc fc)                = 
    Atom $ unparse (exprDoc e1) <+> char '?' <+> ppExpr tc 
                                <+> char ':' <+> ppExpr fc

exprDoc (FunCall pid es)                = 
    Atom $ text (varName pid) <> tupled (map ppExpr es)


ppUnary :: UnaryOp -> DocE -> DocE
ppUnary NEG  = negateU 
ppUnary BNOT = bitwiseNotU

ppBinary :: BinOp -> DocE -> DocE -> DocE
ppBinary ADD        = addB
ppBinary SUB        = subtractB
ppBinary MUL        = multiplyB
ppBinary DIV        = divideB
ppBinary LOG_AND    = logicalAndB
ppBinary LOG_OR     = logicalOrB 
ppBinary MOD        = moduloB

ppCommand :: Command -> Doc
ppCommand (NewPath)                     = text "beginPath()"
ppCommand (ClosePath)                   = text "closePath()"
ppCommand (Fill)                        = text "fill()"
ppCommand (Stroke)                      = text "stroke()"
ppCommand (MoveTo x y)                  = 
    text "moveto" <> tupled (map ppExpr [x,y])

ppCommand (LineTo x y)                  = 
    text "lineto" <> tupled (map ppExpr [x,y])

ppCommand (CurveTo x1 y1 x2 y2 x3 y3)   = 
    text "curveto" <> tupled (map ppExpr [x1,y1,x2,y2,x3,y3])

ppCommand (GSave)                       = text "save()"
ppCommand (GRestore)                    = text "restore()"
ppCommand (Scale x y)                   =
    text "scale" <> tupled (map ppExpr [x,y])

ppCommand (Rotate ang)                  = 
   text "rotate" <> tupled (map ppExpr [ang])

ppCommand (Translate x y)               = 
    text "translate" <> tupled (map ppExpr [x,y])

ppCommand (Transform a b c d e f)       =
    text "transform" <> tupled (map ppExpr [a,b,c,d,e,f])

ppCommand (ShowText e)                  = 
    text "filltext" <> tupled (map ppExpr [e])


ppValue :: Value -> Doc
ppValue (Int i)         = int i
ppValue (Float d)       = truncatedDouble $ realToFrac d
ppValue (String s)      = doubleQuotes $ text s
ppValue (Var s)         = text s



--------------------------------------------------------------------------------

type Code = H Stmt


program :: K.Program -> Mon Program
program (K.Program main_proc defs) = 
    Program <$> fundef1 main_proc <*> mapM fundef1 defs

fundef1 :: K.Fundef -> Mon Fundef
fundef1 (K.Fundef name args body) = 
    (\h -> Fundef name args (fromH h)) <$> topExpr body

topExpr :: K.Expr -> Mon Code
topExpr (K.Val v)               = (wrapH . Return) <$> value v
topExpr (K.FunCall pid vs)      = 
    (\es -> wrapH $ ExprStmt $ FunCall pid es) <$> mapM value vs         

topExpr (K.Let _vid _e1 _e2)    = error "topExpr - K.Let"
{-
topExpr (K.UnaryE op v)         = 
    (\e -> wrapH $ Return $ UnaryE op e) <$> value v

topExpr (K.BinE op v1 v2)       = 
    (\e1 e2 -> wrapH $ Return $ BinE op e1 e2) <$> value v1 <*> value v2
-}

topExpr (K.Ifte v1 e1 e2) = 
    (\re tcase fcase -> wrapH $ IfElse re (fromH tcase) (fromH fcase))
      <$> value v1 <*> expr1 e1 <*> expr1 e2

topExpr (K.Cmd cmd)             = (wrapH . CtxCommand) <$> command cmd
topExpr (e1 K.:>> e2)           = appendH <$> expr1 e1 <*> expr1 e2

expr1 :: K.Expr -> Mon Code
expr1 (K.Cmd cmd)               = (wrapH . CtxCommand) <$> command cmd
expr1 (e1 K.:>> e2)             = appendH <$> expr1 e1 <*> expr1 e2

command :: K.Command -> Mon Command
command (K.NewPath)                     = pure NewPath
command (K.ClosePath)                   = pure ClosePath
command (K.Fill)                        = pure Fill
command (K.Stroke)                      = pure Stroke
command (K.MoveTo x y)                  = MoveTo <$> value x <*> value y
command (K.LineTo x y)                  = LineTo <$> value x <*> value y
command (K.CurveTo x1 y1 x2 y2 x3 y3)   = 
    CurveTo <$> value x1 <*> value y1 
            <*> value x2 <*> value y2
            <*> value x3 <*> value y3

command (K.GSave)                       = pure GSave
command (K.GRestore)                    = pure GRestore
command (K.Scale x y)                   = Scale <$> value x <*> value y
command (K.Rotate ang)                  = Rotate <$> value ang
command (K.Translate x y)               = Translate <$> value x <*> value y
command (K.Transform a b c d e f)       = 
    Transform <$> value a <*> value b <*> value c 
              <*> value d <*> value e <*> value f

command (K.ShowText v)                  = ShowText <$> value v


value :: K.Value -> Mon Expr
value (K.Unit)      = throwError $ "value1 applied to Unit"
value (K.Int i)     = pure $ Val $ Int i
value (K.Float d)   = pure $ Val $ Float d
value (K.String s)  = pure $ Val $ String s
value (K.Var vid)   = pure $ Val $ Var $ varName vid
